home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / scheme / compile < prev    next >
Encoding:
Text File  |  1990-04-03  |  10.2 KB  |  495 lines
  1. (require 'cscheme)
  2.  
  3. ;
  4. ; Optimizing scheme compiler
  5. ; supports quote, set!, if, lambda special forms,
  6. ; constant refs, variable refs and proc applications
  7. ;
  8. ; Using Clusures for Code Generation
  9. ; Marc Feeley and Guy LaPalme
  10. ; Computer Language, Vol. 12, No. 1, pp. 47-66
  11. ; 1987
  12. ;
  13.  
  14. (define (compile expr)
  15.   ((gen expr nil '())))
  16.  
  17. (define (gen expr env term)
  18.   (cond
  19.    ((symbol? expr)
  20.     (ref (variable expr env) term))
  21.    ((not (pair? expr))
  22.     (cst expr term))
  23.    ((eq? (car expr) 'quote)
  24.     (cst (cadr expr) term))
  25.    ((eq? (car expr) 'set!)
  26.     (set (variable (cadr expr) env) (gen (caddr expr) env '()) term))
  27.    ((eq? (car expr) 'if)
  28.     (gen-tst (gen (cadr expr) env '())
  29.           (gen (caddr expr) env term)
  30.           (gen (cadddr expr) env term)))
  31.    ((eq? (car expr) 'lambda)
  32.     (let ((p (cadr expr)))
  33.       (prc p (gen (caddr expr) (allocate p env) #t) term)))
  34.    (else
  35.     (let ((args (map (lambda (x) (gen x env '())) (cdr expr))))
  36.       (let ((var (and (symbol? (car expr)) (variable (car expr) env))))
  37.     (if (global? var)
  38.         (app (cons var args) #t term)
  39.         (app (cons (gen (car expr) env '()) args) '() term)))))))
  40.  
  41.  
  42. (define (allocate parms env)
  43.   (cond ((null? parms) env)
  44.     ((symbol? parms) (cons parms env))
  45.     (else
  46.      (cons (car parms) (allocate (cdr parms) env)))))
  47.  
  48. (define (variable symb env)
  49.   (let ((x (memq symb env)))
  50.     (if x
  51.     (- (length env) (length x))
  52.     (begin
  53.      (if (not (assq symb -glo-env-)) (define-global symb '-undefined-))
  54.      (assq symb -glo-env-)))))
  55.  
  56. (define (global? var)
  57.   (pair? var))
  58.  
  59. (define (cst val term)
  60.   (cond ((eqv? val 1)
  61.      ((if term gen-1* gen-1)))
  62.     ((eqv? val 2)
  63.      ((if term gen-2* gen-2)))
  64.     ((eqv? val nil)
  65.      ((if term gen-null* gen-null)))
  66.     (else
  67.      ((if term gen-cst* gen-cst) val))))
  68.  
  69. (define (ref var term)
  70.   (cond ((global? var)
  71.      ((if term gen-ref-glo* gen-ref-glo) var))
  72.     ((= var 0)
  73.      ((if term gen-ref-loc-1* gen-ref-loc-1)))
  74.     ((= var 1)
  75.      ((if term gen-ref-loc-2* gen-ref-loc-2)))
  76.     ((= var 2)
  77.      ((if term gen-ref-loc-3* gen-ref-loc-3)))
  78.     (else
  79.      ((if term gen-ref* gen-ref) var))))
  80.  
  81. (define (set var val term)
  82.   (cond ((global? var)
  83.      ((if term gen-set-glo* gen-set-glo) var val))
  84.     ((= var 0)
  85.      ((if term gen-set-loc-1* gen-set-loc-1) val))
  86.     ((= var 1)
  87.      ((if term gen-set-loc-2* gen-set-loc-2) val))
  88.     ((= var 2)
  89.      ((if term gen-set-loc-3* gen-set-loc-3) val))
  90.     (else
  91.      ((if term gen-set* gen-set) var val))))
  92.  
  93. (define (prc parms body term)
  94.     ((cond ((null? parms)    
  95.         (if term gen-pr0* gen-pr0))
  96.     ((symbol? parms)
  97.         (if term gen-pr1/rest* gen-pr1/rest))
  98.     ((null? (cdr parms))
  99.         (if term gen-pr1* gen-pr1))
  100.     ((symbol? (cdr parms))
  101.         (if term gen-pr2/rest* gen-pr2/rest))
  102.     ((null? (cddr parms))
  103.         (if term gen-pr2* gen-pr2))
  104.     ((symbol? (cddr parms))
  105.         (if term gen-pr3/rest* gen-pr3/rest))
  106.     ((null? (cdddr parms))
  107.         (if term gen-pr3 gen-pr3))
  108.     (else
  109.         (error "too many parameters in a lambda-expression")))
  110.     body))
  111.  
  112. (define (app vals glo term)
  113.     (apply (case (length vals)
  114.         ((1) (if glo 
  115.             (if term gen-ap0-glo* gen-ap0-glo) 
  116.             (if term gen-ap0* gen-ap0)))
  117.         ((2) (if glo 
  118.             (if term gen-ap1-glo* gen-ap1-glo) 
  119.             (if term gen-ap1* gen-ap1)))
  120.         ((3) (if glo 
  121.             (if term gen-ap2-glo* gen-ap2-glo) 
  122.             (if term gen-ap2* gen-ap2)))
  123.         ((4) (if glo 
  124.             (if term gen-ap3-glo* gen-ap3-glo) 
  125.             (if term gen-ap3* gen-ap3)))
  126.         (else (error "too many arguments in a proc application")))
  127.     vals))
  128. ;
  129. ; code generation for non-terminal evaluations
  130. ;
  131.  
  132. ;
  133. ; constants
  134. ;
  135.  
  136. (define (gen-1)        (lambda () 1))
  137. (define (gen-2)        (lambda () 2))
  138. (define (gen-null)     (lambda () '()))
  139. (define (gen-cst a)    (lambda () a))
  140.  
  141. ;
  142. ; variable reference
  143. ;
  144.  
  145. (define (gen-ref-glo a)    (lambda () (cdr a)))        ; global var
  146. (define (gen-ref-loc-1)    (lambda () (cadr *env*)))    ; first local var
  147. (define (gen-ref-loc-2)    (lambda () (caddr *env*)))    ; second local var
  148. (define (gen-ref-loc-3)    (lambda () (cadddr *env*)))    ; third local var
  149. (define (gen-ref a)    (lambda () (do ((i 0 (1+ i))    ; any non-global
  150.                     (env (cdr *env*) (cdr env)))
  151.                        ((= i a) (car env)))))
  152.  
  153. ;
  154. ; assignment
  155. ;
  156.  
  157. (define (gen-set-glo a b)    (lambda () (set-cdr! a (b))))
  158. (define (gen-set-loc-1 a)    (lambda () (set-car! (cdr *env*) (a))))
  159. (define (gen-set-loc-2 a)    (lambda () (set-car! (cddr *env*) (a))))
  160. (define (gen-set-loc-3 a)    (lambda () (set-car! (cdddr *env*) (a))))
  161. (define (gen-set a b)        (lambda () (do ((i 0 (1+ i))
  162.                         (env (cdr *env*) (cdr env)))
  163.                            ((= i a) (set-car! env (b))))))
  164.  
  165. ;
  166. ; conditional
  167. ;
  168.  
  169. (define (gen-tst a b c)        (lambda () (if (a) (b) (c))))
  170.  
  171. ;
  172. ; procedure application
  173. ;
  174.  
  175. (define (gen-ap0-glo a)        (lambda () ((cdr a))))
  176. (define (gen-ap1-glo a b)    (lambda () ((cdr a) (b))))
  177. (define (gen-ap2-glo a b c)    (lambda () ((cdr a) (b) (c))))
  178. (define (gen-ap3-glo a b c d)    (lambda () ((cdr a) (b) (c) (d))))
  179.  
  180. (define (gen-ap0 a)        (lambda () ((a))))
  181. (define (gen-ap1 a b)        (lambda () ((a) (b))))
  182. (define (gen-ap2 a b c)        (lambda () ((a) (b) (c))))
  183. (define (gen-ap3 a b c d)    (lambda () ((a) (b) (c) (d))))
  184.  
  185. ;
  186. ; lambda expressions
  187. ;
  188.  
  189. (define (gen-pr0 a)    ; without "rest" parameter
  190.   (lambda ()
  191.     (let ((def (cdr *env*)))
  192.       (lambda () 
  193.     (set! *env* (cons *env* def))
  194.     (a)))))
  195.  
  196. (define (gen-pr1 a)
  197.   (lambda ()
  198.     (let ((def (cdr *env*)))
  199.       (lambda (x)
  200.     (set! *env* (cons *env* (cons x def)))
  201.     (a)))))
  202.  
  203. (define (gen-pr2 a)
  204.   (lambda ()
  205.     (let ((def (cdr *env*)))
  206.       (lambda (x y)
  207.     (set! *env* (cons *env* (cons x (cons y def))))
  208.     (a)))))
  209.  
  210. (define (gen-pr3 a)
  211.   (lambda ()
  212.     (let ((def (cdr *env*)))
  213.       (lambda (x y z)
  214.     (set! *env* (cons *env* (cons x (cons y (cons z def)))))
  215.     (a)))))
  216.  
  217. (define (gen-pr1/rest a)
  218.   (lambda ()
  219.     (let ((def (cdr *env*)))
  220.       (lambda x
  221.     (set! *env* (cons *env* (cons x def)))
  222.     (a)))))
  223.  
  224. (define (gen-pr2/rest a)
  225.   (lambda ()
  226.     (let ((def (cdr *env*)))
  227.       (lambda (x . y)
  228.     (set! *env* (cons *env* (cons x (cons y def))))
  229.     (a)))))
  230.  
  231. (define (gen-pr3/rest a)
  232.   (lambda ()
  233.     (let ((def (cdr *env*)))
  234.       (lambda (x y . z)
  235.     (set! *env* (cons *env* (cons x (cons y (cons z def)))))
  236.     (a)))))
  237.  
  238. ;
  239. ; code generation for terminal evaluations
  240. ;
  241.  
  242. ;
  243. ; constants
  244. ;
  245.  
  246. (define (gen-1*)
  247.   (lambda ()
  248.     (set! *env* (car *env*))
  249.     1))
  250.  
  251. (define (gen-2*)
  252.   (lambda ()
  253.     (set! *env* (car *env*))
  254.     2))
  255.  
  256. (define (gen-null*)
  257.   (lambda ()
  258.     (set! *env* (car *env*))
  259.     ()))
  260.  
  261. (define (gen-cst* a)
  262.   (lambda ()
  263.     (set! *env* (car *env*))
  264.     a))
  265.  
  266. ;
  267. ; variable reference
  268. ;
  269.  
  270. (define (gen-ref-glo* a)
  271.   (lambda ()
  272.     (set! *env* (car *env*))
  273.     (cdr a)))
  274.  
  275. (define (gen-ref-loc-1*)
  276.   (lambda ()
  277.     (let ((val (cadr *env*)))
  278.       (set! *env* (car *env*))
  279.       val)))
  280.  
  281. (define (gen-ref-loc-2*)
  282.   (lambda ()
  283.     (let ((val (caddr *env*)))
  284.       (set! *env* (car *env*))
  285.       val)))
  286.  
  287. (define (gen-ref-loc-3*)
  288.   (lambda ()
  289.     (let ((val (cadddr *env*)))
  290.       (set! *env* (car *env*))
  291.       val)))
  292.  
  293. (define (gen-ref* a)
  294.   (lambda ()
  295.     (do ((i 0 (1+ i))
  296.      (env (cdr *env*) (cdr env)))
  297.     ((= i a)
  298.      (set! *env* (car *env*))
  299.      (car env)))))
  300.  
  301. ;
  302. ; assignment
  303. ;
  304.  
  305. (define (gen-set-glo* a b)
  306.   (lambda ()
  307.     (set! *env* (car *env*))
  308.     (set-cdr! a (b))))
  309.  
  310. (define (gen-set-loc-1* a)
  311.   (lambda ()
  312.     (set! *env* (car *env*))
  313.     (set-car! (cdr *env*) (a))))
  314.  
  315. (define (gen-set-loc-2* a)
  316.   (lambda ()
  317.     (set! *env* (car *env*))
  318.     (set-car! (cddr *env*) (a))))
  319.  
  320. (define (gen-set-loc-3* a)
  321.   (lambda ()
  322.     (set! *env* (car *env*))
  323.     (set-car! (cdddr *env*) (a))))
  324.  
  325. (define (gen-set* a b)
  326.   (lambda ()
  327.     (do ((i 0 (1+ i))
  328.      (env (cdr *env*) (cdr env)))
  329.     ((= i 0)
  330.      (set! *env* (car *env*))
  331.      (set-car! env (b))))))
  332.  
  333. ;
  334. ; procedure application
  335. ;
  336.  
  337. (define (gen-ap0-glo* a)
  338.   (lambda ()
  339.     (set! *env* (car *env*))
  340.     ((cdr a))))
  341.  
  342. (define (gen-ap1-glo* a b)
  343.   (lambda ()
  344.     (let ((x (b)))
  345.       (set! *env* (car *env*))
  346.       ((cdr a) x))))
  347.  
  348. (define (gen-ap2-glo* a b c)
  349.   (lambda ()
  350.     (let ((x (b)) (y (c)))
  351.       (set! *env* (car *env*))
  352.       ((cdr a) x y))))
  353.  
  354. (define (gen-ap3-glo* a b c d)
  355.   (lambda ()
  356.     (let ((x (b)) (y (c)) (z (d)))
  357.       (set! *env* (car *env*))
  358.       ((cdr a) x y z))))
  359.  
  360. (define (gen-ap0* a)
  361.   (lambda ()
  362.     (let ((w (a)))
  363.       (set! *env* (car *env*))
  364.       (w))))
  365.  
  366. (define (gen-ap1* a b)
  367.   (lambda ()
  368.     (let ((w (a)) (x (b)))
  369.       (set! *env* (car *env*))
  370.       (w x))))
  371.  
  372. (define (gen-ap2* a b c)
  373.   (lambda ()
  374.     (let ((w (a)) (x (b)) (y (c)))
  375.       (set! *env* (car *env*))
  376.       (w x y))))
  377.  
  378. (define (gen-ap3* a b c d)
  379.   (lambda ()
  380.     (let ((w (a)) (x (b)) (y (c)) (z (d)))
  381.       (set! *env* (car *env*))
  382.       (w x y z))))
  383.  
  384. ;
  385. ; lambda
  386. ;
  387.  
  388. (define (gen-pr0* a)
  389.   (lambda ()
  390.     (let ((def (cdr *env*)))
  391.       (set! *env* (car *env*))
  392.       (lambda ()
  393.     (set! *env* (cons *env* def))
  394.     (a)))))
  395.  
  396.  
  397. (define (gen-pr1* a)
  398.   (lambda ()
  399.     (let ((def (cdr *env*)))
  400.       (set! *env* (car *env*))
  401.       (lambda (x)
  402.     (set! *env* (cons *env* (cons x def)))
  403.     (a)))))
  404.  
  405. (define (gen-pr2* a)
  406.   (lambda ()
  407.     (let ((def (cdr *env*)))
  408.       (set! *env* (car *env*))
  409.       (lambda (x y)
  410.     (set! *env* (cons *env* (cons x (cons y def))))
  411.     (a)))))
  412.  
  413. (define (gen-pr3* a)
  414.   (lambda ()
  415.     (let ((def (cdr *env*)))
  416.       (set! *env* (car *env*))
  417.       (lambda (x y z)
  418.     (set! *env* (cons *env* (cons x (cons y (cons z def)))))
  419.     (a)))))
  420.  
  421. (define (gen-pr1/rest* a)
  422.   (lambda ()
  423.     (let ((def (cdr *env*)))
  424.       (set! *env* (car *env*))
  425.       (lambda x
  426.     (set! *env* (cons *env* (cons x def)))
  427.     (a)))))
  428.  
  429. (define (gen-pr2/rest* a)
  430.   (lambda ()
  431.     (let ((def (cdr *env*)))
  432.       (set! *env* (car *env*))
  433.       (lambda (x . y)
  434.     (set! *env* (cons *env* (cons x (cons y def))))
  435.     (a)))))
  436.  
  437. (define (gen-pr1/rest* a)
  438.   (lambda ()
  439.     (let ((def (cdr *env*)))
  440.       (set! *env* (car *env*))
  441.       (lambda (x y . z)
  442.     (set! *env* (cons *env* (cons x (cons y (cons z def)))))
  443.     (a)))))
  444.  
  445. ;
  446. ; global defs
  447. ;
  448.  
  449. (define (define-global var val)
  450.   (if (assq var -glo-env-)
  451.       (set-cdr! (assq var -glo-env-) val)
  452.         (set! -glo-env- (cons (cons var val) -glo-env-))))
  453.  
  454. (define -glo-env- (list (cons 'define define-global)))
  455.  
  456. (define-global 'cons cons)
  457. (define-global 'car car)
  458. (define-global 'cdr cdr)
  459. (define-global 'null? null?)
  460. (define-global 'not not)
  461. (define-global '< <)
  462. (define-global '-1+ -1+)
  463. (define-global '+ +)
  464. (define-global '- -)
  465.  
  466. ;
  467. ; current environment
  468. ;
  469.  
  470. (define *env* '(dummy))
  471.  
  472. ;
  473. ; environment manipulation
  474. ;
  475.  
  476. (define (restore-env)
  477.   (set! *env* (car *env*)))
  478.  
  479. ;
  480. ; evaluator
  481. ;
  482.  
  483. (define (evaluate expr)
  484.   ((compile (list 'lambda '() expr))))
  485.  
  486.  
  487.  (evaluate '(define 'fib
  488.           (lambda (x)
  489.             (if (< x 2)
  490.             x
  491.             (+ (fib (- x 1))
  492.                (fib (- x 2)))))))
  493.  
  494. (print (evaluate '(fib 10)))
  495.